home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / xermsg.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.1 KB  |  181 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (defun xermsg (librar subrou messg nerr level)
  12.   (declare (type f2cl-lib:integer4 level nerr)
  13.            (type (simple-array base-char (*)) messg subrou librar))
  14.   (prog ((lfirst
  15.           (make-array '(20) :element-type 'base-char :initial-element #\Space))
  16.          (temp
  17.           (make-array '(72) :element-type 'base-char :initial-element #\Space))
  18.          (xlibr
  19.           (make-array '(8) :element-type 'base-char :initial-element #\Space))
  20.          (xsubr
  21.           (make-array '(8) :element-type 'base-char :initial-element #\Space))
  22.          (ltemp 0) (mkntrl 0) (llevel 0) (lerr 0) (kount 0) (i 0) (kdummy 0)
  23.          (f2cl-lib:f2cl-// 0.0f0) (maxmes 0) (lkntrl 0))
  24.     (declare (type single-float f2cl-lib:f2cl-//)
  25.              (type f2cl-lib:integer4 lkntrl maxmes kdummy i kount lerr llevel
  26.               mkntrl ltemp)
  27.              (type (simple-array base-char (8)) xsubr xlibr)
  28.              (type (simple-array base-char (72)) temp)
  29.              (type (simple-array base-char (20)) lfirst))
  30.     (setf lkntrl (j4save 2 0 f2cl-lib:%false%))
  31.     (setf maxmes (j4save 4 0 f2cl-lib:%false%))
  32.     (cond
  33.      ((or (< nerr (f2cl-lib:int-sub 9999999))
  34.           (> nerr 99999999)
  35.           (= nerr 0)
  36.           (< level (f2cl-lib:int-sub 1))
  37.           (> level 2))
  38.       (xerprn " ***" -1
  39.        (f2cl-lib:f2cl-//
  40.         (f2cl-lib:f2cl-// "FATAL ERROR IN...$$ "
  41.                           "XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ ")
  42.         "JOB ABORT DUE TO FATAL ERROR.")
  43.        72)
  44.       (multiple-value-bind
  45.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  46.           (xersve " " " " " " 0 0 0 kdummy)
  47.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
  48.         (setf kdummy var-6))
  49.       (xerhlt " ***XERMSG -- INVALID INPUT") (go end_label)))
  50.     (setf i (j4save 1 nerr f2cl-lib:%true%))
  51.     (multiple-value-bind
  52.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  53.         (xersve librar subrou messg 1 nerr level kount)
  54.       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
  55.       (setf kount var-6))
  56.     (if (and (= level -1) (> kount 1)) (go end_label))
  57.     (f2cl-lib:f2cl-set-string xlibr librar (string 8))
  58.     (f2cl-lib:f2cl-set-string xsubr subrou (string 8))
  59.     (f2cl-lib:f2cl-set-string lfirst messg (string 20))
  60.     (setf lerr nerr)
  61.     (setf llevel level)
  62.     (xercnt xlibr xsubr lfirst lerr llevel lkntrl)
  63.     (setf lkntrl
  64.             (max (the f2cl-lib:integer4 -2)
  65.                  (the f2cl-lib:integer4
  66.                       (min (the f2cl-lib:integer4 2)
  67.                            (the f2cl-lib:integer4 lkntrl)))))
  68.     (setf mkntrl (f2cl-lib:int (abs lkntrl)))
  69.     (if (and (< level 2) (= lkntrl 0)) (go label30))
  70.     (if (and (= level 0) (> kount maxmes)) (go label30))
  71.     (if (and (= level 1) (> kount maxmes) (= mkntrl 1)) (go label30))
  72.     (if
  73.      (and (= level 2)
  74.           (> kount
  75.              (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 maxmes))))
  76.      (go label30))
  77.     (cond
  78.      ((/= lkntrl 0)
  79.       (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 21))
  80.                             "MESSAGE FROM ROUTINE ")
  81.       (setf i
  82.               (min (the f2cl-lib:integer4 (f2cl-lib:len subrou))
  83.                    (the f2cl-lib:integer4 16)))
  84.       (f2cl-lib:fset-string
  85.        (f2cl-lib:fref-string temp (22 (f2cl-lib:int-add 21 i)))
  86.        (f2cl-lib:fref-string subrou (1 i)))
  87.       (f2cl-lib:fset-string
  88.        (f2cl-lib:fref-string temp ((+ 22 i) (f2cl-lib:int-add 33 i)))
  89.        " IN LIBRARY ")
  90.       (setf ltemp (f2cl-lib:int-add 33 i))
  91.       (setf i
  92.               (min (the f2cl-lib:integer4 (f2cl-lib:len librar))
  93.                    (the f2cl-lib:integer4 16)))
  94.       (f2cl-lib:fset-string
  95.        (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp i)))
  96.        (f2cl-lib:fref-string librar (1 i)))
  97.       (f2cl-lib:fset-string
  98.        (f2cl-lib:fref-string temp ((+ ltemp i 1) (f2cl-lib:int-add ltemp i 1)))
  99.        ".")
  100.       (setf ltemp (f2cl-lib:int-add ltemp i 1))
  101.       (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
  102.     (cond
  103.      ((> lkntrl 0)
  104.       (cond
  105.        ((<= level 0)
  106.         (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 20))
  107.                               "INFORMATIVE MESSAGE,")
  108.         (setf ltemp 20))
  109.        ((= level 1)
  110.         (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 30))
  111.                               "POTENTIALLY RECOVERABLE ERROR,")
  112.         (setf ltemp 30))
  113.        (t
  114.         (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 12))
  115.                               "FATAL ERROR,")
  116.         (setf ltemp 12)))
  117.       (cond
  118.        ((or (and (= mkntrl 2) (>= level 1)) (and (= mkntrl 1) (= level 2)))
  119.         (f2cl-lib:fset-string
  120.          (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 14)))
  121.          " PROG ABORTED,")
  122.         (setf ltemp (f2cl-lib:int-add ltemp 14)))
  123.        (t
  124.         (f2cl-lib:fset-string
  125.          (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 16)))
  126.          " PROG CONTINUES,")
  127.         (setf ltemp (f2cl-lib:int-add ltemp 16))))
  128.       (cond
  129.        ((> lkntrl 0)
  130.         (f2cl-lib:fset-string
  131.          (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 20)))
  132.          " TRACEBACK REQUESTED")
  133.         (setf ltemp (f2cl-lib:int-add ltemp 20)))
  134.        (t
  135.         (f2cl-lib:fset-string
  136.          (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 24)))
  137.          " TRACEBACK NOT REQUESTED")
  138.         (setf ltemp (f2cl-lib:int-add ltemp 24))))
  139.       (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
  140.     (xerprn " *  " -1 messg 72)
  141.     (cond
  142.      ((> lkntrl 0)
  143.       (tagbody
  144.         (f2cl-lib:fformat temp ("ERROR NUMBER = " 1 (("~8D")) "~%") nerr)
  145.         (f2cl-lib:fdo (i 16 (f2cl-lib:int-add i 1))
  146.                       ((> i 22) nil)
  147.           (tagbody
  148.             (if (f2cl-lib:fstring-/= (f2cl-lib:fref-string temp (i i)) " ")
  149.                 (go label20))
  150.            label10))
  151.        label20
  152.         (xerprn " *  " -1
  153.          (f2cl-lib:f2cl-// (f2cl-lib:fref-string temp (1 15))
  154.                            (f2cl-lib:fref-string temp (i 23)))
  155.          72)
  156.         (fdump))))
  157.     (cond
  158.      ((/= lkntrl 0) (xerprn " *  " -1 " " 72)
  159.       (xerprn " ***" -1 "END OF MESSAGE" 72) (xerprn "    " 0 " " 72)))
  160.    label30
  161.     (if (or (<= level 0) (and (= level 1) (<= mkntrl 1))) (go end_label))
  162.     (cond
  163.      ((and (> lkntrl 0)
  164.            (< kount
  165.               (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 maxmes))))
  166.       (cond
  167.        ((= level 1)
  168.         (xerprn " ***" -1 "JOB ABORT DUE TO UNRECOVERED ERROR." 72))
  169.        (t (xerprn " ***" -1 "JOB ABORT DUE TO FATAL ERROR." 72)))
  170.       (multiple-value-bind
  171.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  172.           (xersve " " " " " " -1 0 0 kdummy)
  173.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
  174.         (setf kdummy var-6))
  175.       (xerhlt " "))
  176.      (t (xerhlt messg)))
  177.     (go end_label)
  178.    end_label
  179.     (return (values nil nil nil nil nil))))
  180.  
  181.